home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / doc / popularity-contest / examples / popcon.pl < prev    next >
Encoding:
Perl Script  |  2008-11-04  |  13.4 KB  |  461 lines
  1. #! /usr/bin/perl -wT
  2.  
  3. $results="../popcon-mail/results";
  4. $popcon="../www";
  5. my $mirrorbase = "/org/ftp.root/debian";
  6. my $docurlbase = "";
  7.  
  8. sub htmlheader
  9. {
  10.   print HTML <<"EOH";
  11.   <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
  12.   <html>
  13.   <head>
  14.     <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
  15.       <title> Debian Popularity Contest </title>
  16.         <link rev="made" href="mailto:ballombe\@debian.org">
  17.         <link rel="shortcut icon" href="/favicon.ico">
  18.         </head>
  19.         <body text="#000000" bgcolor="#FFFFFF" link="#0000FF" vlink="#800080" alink="#FF0000">
  20.         <div align="center">
  21.         <a href="http://www.debian.org/">
  22.         <img src="http://www.debian.org/logos/openlogo-nd-50.png" border="0" hspace="0" vspace="0" alt="" width="50" height="61">
  23.         </a>
  24.         <a href="http://www.debian.org/">
  25.         <img src="http://www.debian.org/Pics/debian.jpg" border="0" hspace="0" vspace="0" alt="Debian Project" width="179" height="61">
  26.         </a>
  27.         </div>
  28.         <br>
  29.         <table bgcolor="#DF0451" border="0" width="100%" cellpadding="0" cellspacing="0" summary="">
  30.         <tr>
  31.         <td valign="top">
  32.         <img src="http://www.debian.org/Pics/red-upperleft.png" align="left" border="0" hspace="0" vspace="0" alt="" width="15" height="16">
  33.         </td>
  34.         <td rowspan="2" align="center">
  35.         <font color="#FFFF00"><big><big>Debian Popularity Contest</big></big></font>
  36.         </td>
  37.         <td valign="top">
  38.         <img src="http://www.debian.org/Pics/red-upperright.png" align="right" border="0" hspace="0" vspace="0" alt="" width="16" height="16">
  39.         </td>
  40.         </tr>
  41.         <tr>
  42.         <td valign="bottom">
  43.         <img src="http://www.debian.org/Pics/red-lowerleft.png" align="left" border="0" hspace="0" vspace="0" alt="" width="16" height="16">
  44.         </td>
  45.         <td valign="bottom">
  46.         <img src="http://www.debian.org/Pics/red-lowerright.png" align="right" border="0" hspace="0" vspace="0" alt="" width="15" height="16">
  47.         </td>
  48.         </tr>
  49.         </table>
  50. EOH
  51. }
  52.  
  53. sub popconintro
  54. {
  55.   print HTML <<"EOH";
  56.   <p> <em> The popularity contest project is an attempt to map the usage of
  57.   Debian packages.  This site publishes the statistics gathered from report
  58.   sent by users of the <a
  59.   href="http://packages.debian.org/popularity-contest">popularity-contest</a>
  60.   package. This package sends every week the list of packages installed and the
  61.   access time of relevant files to the server via email. Every day the server
  62.   anonymizes the result and publishes this survey.
  63.   For more information, read the <a href="${docurlbase}README">README</a> and the 
  64.   <a href="${docurlbase}FAQ">FAQ</a>.
  65.   </em> <p>
  66. <form method="GET" action="http://qa.debian.org/popcon.php">Popcon statistics
  67. for source package <input type="text" size="30" maxlength="80" name="package">
  68. <input type="submit" value="Go">
  69. </form> <p>
  70. EOH
  71. }
  72.  
  73. sub htmlfooter
  74. {
  75.   my $date=gmtime();
  76.   print HTML <<EOF;
  77. <pre>
  78. inst     : number of people who installed this package;
  79. vote     : number of people who use this package regularly;
  80. old      : number of people who installed, but don't use this package regularly;
  81. recent   : number of people who upgraded this package recently;
  82. no-files : number of people whose entry didn't contain enough information (atime
  83. and ctime were 0).
  84. </pre>
  85. <p>
  86. Number of submissions considered: $numsub
  87. </p><p>
  88. To participate in this survey, install the <a href="http://packages.debian.org/popularity-contest">popularity-contest</a> package.
  89. </p>
  90. EOF
  91.   print HTML <<EOH
  92. <p>
  93. <HR>
  94. <small>
  95. Made by <a href="mailto:ballombe\@debian.org"> Bill Allombert </a>. Last generated on $date UTC. <br>
  96. <a href="http://popcon.alioth.debian.org" > Popularity-contest project </a> by Avery Pennarun, Bill Allombert and Petter Reinholdtsen.
  97. <BR>
  98. Copyright (C) 2004-2005 <A HREF="http://www.spi-inc.org/">SPI</A>;
  99. See <A HREF="http://www.debian.org/license">license terms</A>.
  100. </small>
  101. </body>
  102. </html>
  103. EOH
  104. }
  105.  
  106. sub make_sec
  107. {
  108.   my $sec="$popcon/$_[0]";
  109.   -d $sec || system("mkdir","-p","$sec");
  110. }
  111.  
  112. sub print_by
  113. {
  114.    my ($dir,$f)=@_;
  115.    print HTML ("<a href=\"$dir/by_$f\">$f</a> [<a href=\"$dir/by_$f.gz\">gz</a>] ");
  116. }
  117.  
  118. %list_header=(
  119. "maint" => <<"EOF",
  120. #<name> is the developer name;
  121. #
  122. #The fields below are the sum for all the packages maintained by that
  123. #developer:
  124. EOF
  125. "source" => <<"EOF");
  126. #<name> is the source package name;
  127. #
  128. #The fields below are the sum for all the binary packages generated by
  129. #that source package:
  130. EOF
  131.  
  132. sub make_by
  133. {
  134.   my ($sec,$order,$pkg,@list) = @_;
  135.   my (%sum, $me);
  136.   @list = sort {$pkg->{$b}->{$order}<=> $pkg->{$a}->{$order} || $a cmp $b } @list;
  137.   $winner{"$sec/$order"}=$list[0];
  138.   open DAT , "|-:utf8", "tee $popcon/$sec/by_$order | gzip -c > $popcon/$sec/by_$order.gz";
  139.   if (defined($list_header{$sec}))
  140.   {
  141.     print DAT $list_header{$sec};
  142.     $me="";
  143.   }
  144.   else 
  145.   {
  146.     print DAT <<"EOF";
  147. #Format
  148. #   
  149. #<name> is the package name;
  150. EOF
  151.     $me="(maintainer)";
  152.   }
  153.   print DAT << "EOF";
  154. #<inst> is the number of people who installed this package;
  155. #<vote> is the number of people who use this package regularly;
  156. #<old> is the number of people who installed, but don't use this package
  157. #      regularly;
  158. #<recent> is the number of people who upgraded this package recently;
  159. #<no-files> is the number of people whose entry didn't contain enough
  160. #           information (atime and ctime were 0).
  161. #rank name                            inst  vote   old recent no-files $me
  162. EOF
  163.   $format="%-5d %-30s".(" %5d"x($#fields+1))." %-32s\n";
  164.   my $rank=0;
  165.   for $p (@list)
  166.   {
  167.     $rank++;
  168.     my $m=(defined($list_header{$sec})?"":"($maint{$p})");
  169.     printf  DAT $format, $rank, $p, (map {$pkg->{$p}->{$_}} @fields), $m;
  170.     $sum{$_}+=$pkg->{$p}->{$_} for (@fields);
  171.   }
  172.   print  DAT '-'x66,"\n";
  173.   printf DAT $format, $rank, "Total", map {defined($sum{$_})?$sum{$_}:0} @fields, "";
  174.   close DAT;
  175. }
  176.  
  177. sub make
  178. {
  179.   my ($sec,$pkg,@list)=@_;
  180.   make_sec $sec;
  181.   make_by ($sec, $_, $pkg, @list) for (@fields);
  182. }
  183. sub print_pkg
  184. {
  185.   my ($pkg)=@_;
  186.   return unless (defined($pkg));
  187.   my $size=length $pkg;
  188.   my $pkgt=substr($pkg,0,20);
  189.   print HTML "<a href=\"http://packages.debian.org/$pkg\">$pkgt</a> ",
  190.   ' 'x(20-$size);
  191. }
  192. sub mark
  193. {
  194.   print join(" ",$_[0],times),"\n";
  195. }
  196.  
  197. %pkg=();
  198. %section=();
  199. %maint=();
  200. %source=();
  201. %winner=();
  202. %maintpkg=();
  203. %sourcepkg=();
  204. @fields=("inst","vote","old","recent","no-files");
  205.  
  206. for $file ("slink","slink-nonUS","potato","potato-nonUS",
  207.            "woody","woody-nonUS","sarge")
  208. {
  209.   open AVAIL, "<:utf8", "$file.sections" or die "Cannot open $file.sections";
  210.   while(<AVAIL>)
  211.   {
  212.       my ($p,$sec)=split(' ');
  213.       defined($sec) or last;
  214.       chomp $sec;
  215.       $sec =~ m{^(non-US|contrib|non-free)/} or $sec="main/$sec";
  216.       $section{$p}=$sec;
  217.       $maint{$p}="Not in sid";
  218.       $source{$p}="Not in sid";
  219.   }
  220.   close AVAIL;
  221. }
  222. mark "Reading legacy packages...";
  223. $ENV{PATH}="/bin:/usr/bin";
  224.  
  225. for (glob("/org/ftp.root/debian/dists/stable/*/binary-*/Packages.gz"),
  226.            glob("/org/ftp.root/debian/dists/testing/*/binary-*/Packages.gz"),
  227.            glob("/org/ftp.root/debian/dists/sid/*/binary-*/Packages.gz"))
  228. {
  229.   /([^[:space:]]+)/ or die("incorrect package name");
  230.   $file = $1;#Untaint
  231.   open AVAIL, "-|:encoding(UTF-8)","zcat $file";
  232.   while(<AVAIL>)
  233.   {
  234. /^Package: (.+)/  and do {$p=$1;$maint{$p}="bug";$source{$p}=$p;next;};
  235. /^Maintainer: ([^()]+) (\(.+\) )*<.+>/ and do { $maint{$p}=join(' ',map{ucfirst($_)} split(' ',lc $1));next;};
  236. /^Source: (\S+)/ and do { $source{$p}=$1;next;};
  237. /^Section: (.+)/ or next;
  238.           $sec=$1;
  239.           $sec =~ m{^(non-US|contrib|non-free)/} or $sec="main/$sec";
  240.           $section{$p}=$sec;
  241.   }
  242.   close AVAIL;
  243. }
  244. mark "Reading current packages...";
  245.  
  246.  
  247. #Format
  248. #<name> <vote> <old> <recent> <no-files>
  249. #   
  250. #<name> is the package name;
  251. #<vote> is the number of people who use this package regularly;
  252. #<old> is the number of people who installed, but don't use this package
  253. #        regularly;
  254. #<recent> is the number of people who upgraded this package recently;
  255. #<no-files> is the number of people whose entry didn't contain enough
  256. #        information (atime and ctime were 0).
  257. open PKG, "<:utf8","$results";
  258. while(<PKG>)
  259. {
  260.   my ($type,@values)=split(" ");
  261.   if ($type eq "Package:")
  262.   {
  263.           my @votes=@values;
  264.       $name = shift @votes;
  265.       unshift @votes,$votes[0]+$votes[1]+$votes[2]+$votes[3];
  266.       $section{$name}='unknown' unless (defined($section{$name}));
  267.       $maint{$name}='Not in sid' unless (defined($maint{$name}));
  268.       $source{$name}='Not in sid' unless (defined($source{$name}));
  269.       for(my $i=0;$i<=$#fields;$i++)
  270.       {
  271.           my ($f,$v)=($fields[$i],$votes[$i]);
  272.           $pkg{$name}->{$f}=$v;
  273.           $maintpkg{$maint{$name}}->{$f}+=$v;
  274.           $sourcepkg{$source{$name}}->{$f}+=$v;
  275.       }
  276.   }
  277.   elsif ($type eq "Architecture:")
  278.   {
  279.     my ($a,$nb)=@values;
  280.     $arch{$a}=$nb;
  281.   }
  282.   elsif ($type eq "Submissions:")
  283.   {
  284.     ($numsub)=@values;
  285.   }
  286.   elsif ($type eq "Release:")
  287.   {
  288.     my ($a,$nb)=@values;
  289.     $release{$a}=$nb;
  290.   }
  291. }
  292. mark "Reading stats...";
  293.  
  294. @pkgs=sort keys %pkg;
  295. %sections = map {$section{$_} => 1} keys %section;
  296. @sections = sort keys %sections;
  297. @maints= sort keys %maintpkg;
  298. @sources= sort keys %sourcepkg;
  299.  
  300. for $sec (@sections)
  301. {
  302.   my @list = grep {$section{$_} eq $sec} @pkgs;
  303.   make ($sec, \%pkg, @list);
  304. }
  305.  
  306. mark "Building by sections pages";
  307.  
  308. @dists=("main","contrib","non-free","non-US");
  309. #There is a hack: '.' is both the current directory and
  310. #the catchall regexp.
  311.  
  312. for $sec (".",@dists)
  313. {
  314.   my @list = grep {$section{$_} =~ /^$sec/ } @pkgs;
  315.   make ($sec, \%pkg, @list);
  316. }
  317. make ("maint", \%maintpkg, @maints);
  318. make ("source", \%sourcepkg, @sources);
  319.  
  320. for $sec (@dists)
  321. {
  322.   open HTML , ">:utf8", "$popcon/$sec/index.html";
  323.   opendir SEC,"$popcon/$sec";
  324.   &htmlheader;
  325.   printf HTML ("<p>Statistics for the section %-16s sorted by fields: ",$sec);
  326.   print_by (".",$_) for (@fields);
  327.   print HTML ("\n </p> \n");
  328.   printf HTML ("<p> <a href=\"first.html\"> First packages in subsections for each fields </a>\n");
  329.   printf HTML ("<p>Statistics for subsections sorted by fields\n <pre>\n");
  330.   for $dir (sort readdir SEC)
  331.   {
  332.     -d "$popcon/$sec/$dir" or next;
  333.     $dir !~ /^\./ or next;
  334.     printf HTML ("%-16s : ",$dir);
  335.     print_by ($dir,$_) for (@fields);
  336.     print HTML ("\n");
  337.   }
  338.   print HTML ("\n </pre>\n");
  339.   &htmlfooter;
  340.   closedir SEC;
  341.   close HTML;
  342. }
  343. mark "Building by sub-sections pages";
  344. for $sec (@dists)
  345. {
  346.   open HTML , ">:utf8", "$popcon/$sec/first.html";
  347.   opendir SEC,"$popcon/$sec";
  348.   &htmlheader;
  349.   printf HTML ("<p>First package in section %-16s for fields: ",$sec);
  350.   for $f (@fields)
  351.   {
  352.       print_pkg $winner{"$sec/$f"};
  353.   }
  354.   print HTML ("\n </p> \n");
  355.   printf HTML ("<p> <a href=\"index.html\"> Statistics by subsections sorted by fields </a>\n");
  356.   printf HTML ("<p>First package in subsections for fields\n <pre>\n");
  357.   printf HTML ("%-16s : ","subsection");
  358.   for $f (@fields)
  359.   {
  360.       printf HTML ("%-20s ",$f);
  361.   }
  362.   print HTML ("\n","_"x120,"\n");
  363.   for $dir (sort readdir SEC)
  364.   {
  365.       -d "$popcon/$sec/$dir" or next;
  366.       $dir !~ /^\./ or next;
  367.       printf HTML ("%-16s : ",$dir);
  368.       for $f (@fields)
  369.       {
  370.           print_pkg $winner{"$sec/$dir/$f"};
  371.       }
  372.       print HTML ("\n");
  373.   }
  374.   print HTML ("\n </pre>\n");
  375.   &htmlfooter;
  376.   closedir SEC;
  377.   close HTML;
  378. }
  379.  
  380. mark "Building winner pages";
  381.  
  382. {
  383.     open HTML , ">:utf8", "$popcon/index.html";
  384.     &htmlheader;
  385.     &popconintro;
  386.     printf HTML ("<p>Statistics for the whole archive sorted by fields: <pre>",$sec);
  387.     print_by (".",$_) for (@fields);
  388.     print HTML ("</pre>\n </p> \n");
  389.     printf HTML ("<p>Statistics by maintainers sorted by fields: <pre>",$sec);
  390.     print_by ("maint",$_) for (@fields);
  391.     print HTML ("</pre>\n </p> \n");
  392.     printf HTML ("<p>Statistics by source packages sorted by fields: <pre>",$sec);
  393.     print_by ("source",$_) for (@fields);
  394.     print HTML ("</pre>\n </p> \n");
  395.     printf HTML ("<p>Statistics for sections sorted by fields\n <pre>\n");
  396.       for $dir ("main","contrib","non-free","non-US","unknown")
  397.     {
  398.         -d "$popcon/$dir" or next;
  399.         $dir !~ /^\./ or next;
  400.         if ($dir eq "unknown")
  401.         {
  402.             printf HTML ("%-16s : ",$dir);
  403.         }
  404.         else
  405.         {
  406.             printf HTML ("<a href=\"$dir/index.html\">%-16s</a> : ",$dir);
  407.         }
  408.         print_by ($dir,$_) for (@fields);
  409.         print HTML ("\n");
  410.     }
  411.     print HTML  <<'EOF';
  412. </pre>
  413. <table border="0" cellpadding="5" cellspacing="0" width="100%">
  414. <tr>
  415. <td>
  416. Statistics per Debian architectures:
  417. <pre>
  418. EOF
  419.         for $f (grep { $_ ne 'unknown' } sort keys %arch)
  420.         {
  421.         my ($port)=split('-',$f);
  422.         $port="$port/";
  423.         $port="kfreebsd-gnu/" if ($port eq "kfreebsd/");
  424.                 printf HTML "<a href=\"http://www.debian.org/ports/$port\">%-16s</a> : %-10s <a href=\"stat/sub-$f.png\">graph</a>\n",$f,$arch{$f};
  425.         }
  426.         if (defined $arch{"unknown"}) {
  427.             printf HTML "%-16s : %-10s <a href=\"stat/sub-unknown.png\">graph</a>\n","unknown",$arch{"unknown"}
  428.         }
  429.     print HTML  <<'EOF';
  430. </pre></td>
  431. <td>
  432.  <img alt="Graph of number of submissions per architectures"
  433.  width="600" height="400" src="stat/submission.png">
  434. </td></tr>
  435. <tr><td>
  436. Statistics per popularity-contest releases:
  437. <pre>
  438. EOF
  439.         for $f (grep { $_ ne 'unknown' } sort keys %release)
  440.         {
  441.                 printf HTML "%-16s : %-10s \n",$f,$release{$f};
  442.         }
  443.         if (defined $release{"unknown"}) {
  444.             printf HTML "%-16s : %-10s \n","unknown",$release{"unknown"};
  445.         }
  446.     print HTML  <<'EOF';
  447. </pre></td>
  448. <td>
  449.  <img alt="Graph of popularity-contest versions in use"
  450.   width="600" height="400" src="stat/release.png">
  451. </td></tr>
  452. </table>
  453. <p>
  454. EOF
  455.  
  456.     print HTML "<a href=\"all-popcon-results.txt.gz\">Raw popularity-contest results</a>\n";
  457.     &htmlfooter;
  458.     close HTML;
  459. }
  460. mark "Building index.html";
  461.